home *** CD-ROM | disk | FTP | other *** search
/ Internet Surfer: Getting Started / Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin / pc / mac / bonus / peter_le / talk_sou / my_libra / mystanda.uni < prev    next >
Text File  |  1992-04-20  |  7KB  |  246 lines
  1. unit MyStandardFile;
  2.  
  3. { This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
  4.  
  5. interface
  6.  
  7.     type
  8.         MySFReply = record
  9.                 Rgood: boolean;
  10.                 Rfolder: boolean;
  11.                 RfType: OSType;
  12.                 RvRefNum: integer;
  13.                 RdirID: longInt;
  14.                 RfName: str63;
  15.             end;
  16.  
  17.     function MFSPt: point;
  18.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MySFReply);
  19.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  20.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  21. { NOTE: GetFolder must be passed a Dialog ID with Button 11 being a folder button }
  22. { NOTE: reply.copy should be interpreted as reply.folder }
  23.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  24.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  25. { NOTE: PutFolder must be passed a Dialog ID with Button 9 being a folder button }
  26. { NOTE: reply.copy should be interpreted as reply.folder }
  27.     function Button11Hook (item: integer; dlg: DialogPtr): integer;
  28. { NOTE: Button11Hook sets Button11 when it converts Button 11 to Button 1 (Open) }
  29.     function Button9Hook (item: integer; dlg: DialogPtr): integer;
  30. { NOTE: Button9Hook sets Button9 when it converts Button 9 to Button 1 (Save) }
  31.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  32.     procedure SegmentStandardFile;
  33.  
  34. implementation
  35.  
  36.     uses
  37.         MyTypes, MyUtils, MyUtilities, MyFileSystem, MyButtons;
  38.  
  39.  {$S StandardFile}
  40.     procedure SegmentStandardFile;
  41.     begin
  42.     end;
  43.  
  44.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  45.         var
  46.             oe: OSErr;
  47.             vrn: integer;
  48.             procID: longInt;
  49.             s: str255;
  50.     begin
  51.         if dirID = 0 then
  52.             oe := GetWDInfo(wdrn, vrn, dirID, procID)
  53.         else
  54.             vrn := wdrn;
  55.         integerP(SFSaveDiskA)^ := -vrn;
  56.         longIntP(CurDirStoreA)^ := dirID;
  57.     end;
  58.  
  59.     function MFSPt: point;
  60.         var
  61.             pt: point;
  62.     begin
  63.         pt.v := 40;
  64.         pt.h := 40;
  65.         MFSPt := pt;
  66.     end;
  67.  
  68.     procedure SetStdReply (var reply: MySFReply; stdReply: StandardFileReply);
  69.     begin
  70.         with reply do begin
  71.             Rgood := stdReply.sfGood;
  72.             Rfolder := ord(stdReply.sfIsFolder) <> 0;        { Argghhh!  Bloody Apple and there C booleans! }
  73.             RfType := stdReply.sfType;
  74.             RvRefNum := stdReply.sfFile.vRefNum;
  75.             RdirID := stdReply.sfFile.parID;
  76.             RfName := stdReply.sfFile.name;
  77.         end;
  78.     end;
  79.  
  80.     procedure SetOldReply (var reply: MySFReply; oldReply: SFReply);
  81.         var
  82.             oe: OSErr;
  83.     begin
  84.         with reply do begin
  85.             Rgood := oldReply.good;
  86.             Rfolder := oldReply.copy;
  87.             RfType := oldReply.fType;
  88.             oe := GetDirID(oldReply.vRefNum, RvRefNum, RdirID);
  89.             RfName := oldReply.fName;
  90.         end;
  91.     end;
  92.  
  93.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MySFReply);
  94.         var
  95.             stdReply: StandardFileReply;
  96.             oldReply: SFReply;
  97.     begin
  98.         with reply do
  99.             if has_newStdFile then begin
  100.                 StandardGetFile(ffilter, numTypes, typeList, stdReply);
  101.                 SetStdReply(reply, stdReply);
  102.             end
  103.             else begin
  104.                 SFGetFile(MFSPt, '', ffilter, numTypes, typeList, nil, oldReply);
  105.                 oldReply.copy := false;
  106.                 SetOldReply(reply, oldReply);
  107.             end;
  108.     end;
  109.  
  110.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  111.         var
  112.             typeList: SFTypeList;
  113.     begin
  114.         if t = OSType(noType) then
  115.             GetFile(nil, -1, typeList, reply)
  116.         else begin
  117.             typeList[0] := t;
  118.             GetFile(nil, 1, typeList, reply);
  119.         end;
  120.     end;
  121.  
  122.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  123.         var
  124.             stdReply: StandardFileReply;
  125.             oldReply: SFReply;
  126.     begin
  127.         with reply do
  128.             if has_newStdFile then begin
  129.                 StandardPutFile(str, origname, stdReply);
  130.                 SetStdReply(reply, stdReply);
  131.             end
  132.             else begin
  133.                 SFPutFile(MFSPt, str, origname, nil, oldReply);
  134.                 oldReply.copy := false;
  135.                 SetOldReply(reply, oldReply);
  136.             end;
  137.     end;
  138.  
  139.     var
  140.         oldReply: SFReply;
  141.         newReply: StandardFileReply;
  142. { item1 is ThisFolder }
  143.         item1: integer;
  144.         button1: boolean;
  145.         active1: boolean;
  146.  
  147.     procedure SetButtons (dlg: dialogPtr);
  148.         var
  149.             new1: boolean;
  150.     begin
  151.         if has_newStdFile then begin
  152.             new1 := newReply.sfFile.parID <> 1; { everywhere except  desktop???? }
  153.         end
  154.         else begin
  155.             new1 := true;
  156.         end;
  157.         SetButton(dlg, item1, active1, new1);
  158.     end;
  159.  
  160.     function ButtonModalFilter (dlg: dialogPtr; var er: eventRecord; var item: integer): boolean;
  161.     begin
  162.         SetButtons(dlg);
  163.         if (er.what = updateEvt) and (dlg = dialogPtr(er.message)) then begin
  164.             UpdateButton(dlg, item1, active1);
  165.         end;
  166.         ButtonModalFilter := false;
  167.     end;
  168.  
  169.     function ButtonModalFilterSys7 (dlg: dialogPtr; var er: eventRecord; var item: integer; data: ptr): boolean;
  170.     begin
  171.         ButtonModalFilterSys7 := ButtonModalFilter(dlg, er, item);
  172.     end;
  173.  
  174.     function ButtonHook (item: integer; dlg: DialogPtr): integer;
  175.     begin
  176.         if not has_newStdFile or (GetWRefCon(dlg) = longint(sfMainDialogRefCon)) then begin
  177.             if item = sfHookFirstCall then begin
  178.                 button1 := false;
  179.                 InitButton(dlg, item1, active1, active1);
  180.                 SetButtons(dlg);
  181.             end;
  182.             if active1 then begin
  183.                 if item <> sfHookLastCall then begin
  184.                     button1 := item = item1;
  185.                     if button1 then
  186.                         item := sfItemOpenButton;
  187.                 end;
  188.             end;
  189.         end;
  190.         ButtonHook := item;
  191.     end;
  192.  
  193.     function ButtonHookSys7 (item: integer; dlg: DialogPtr; data: ptr): integer;
  194.     begin
  195.         ButtonHookSys7 := ButtonHook(item, dlg);
  196.     end;
  197.  
  198.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  199.     begin
  200.         if has_newStdFile then begin
  201.             item1 := 13;
  202.             active1 := true;
  203.             CustomPutFile(str, origName, newReply, id + 1, MFSPt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, nil); {@ButtonModalFilterSys7}
  204.             SetStdReply(reply, newReply);
  205.             reply.Rfolder := button1;
  206.         end
  207.         else begin
  208.             item1 := 9;
  209.             active1 := true;
  210.             SFPPutFile(MFSPt, str, origname, @ButtonHook, oldReply, id, nil);
  211.             oldReply.copy := button1;
  212.             SetOldReply(reply, oldReply);
  213.         end;
  214.     end;
  215.  
  216.     function CallFileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  217.     inline
  218.         $205F, $4E90;
  219.  
  220.     function FileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  221.     begin
  222.         if (BAND(pb^.ioFlAttrib, $0010) = 0) and (addr <> nil) then
  223.             FileFilterSys7 := CallFileFilterSys7(pb, addr)
  224.         else
  225.             FileFilterSys7 := false;
  226.     end;
  227.  
  228.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  229.     begin
  230.         if has_newStdFile then begin
  231.             item1 := 10;
  232.             active1 := true;
  233.             CustomGetFile(@FileFilterSys7, numTypes, typeList, newReply, id + 1, MFSpt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, ffilter);
  234.             SetStdReply(reply, newReply);
  235.             reply.Rfolder := button1;
  236.         end
  237.         else begin
  238.             item1 := 11;
  239.             active1 := true;
  240.             SFPGetFile(MFSPt, '', ffilter, numTypes, typeList, @ButtonHook, oldReply, id, nil);
  241.             oldReply.copy := button1;
  242.             SetOldReply(reply, oldReply);
  243.         end;
  244.     end;
  245.  
  246. end.